home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / link / aegis_link.t next >
Encoding:
Text File  |  1988-02-05  |  8.1 KB  |  226 lines
  1. (herald aem68link (env t (link defs)))
  2.  
  3. ;;; Look at image.doc and template.doc
  4.  
  5.  
  6. (define-local-syntax (dotimes spec . body)
  7.   (let ((index (car spec))
  8.         (limit (cadr spec)))
  9.     `(do ((,index 0 (fx+ ,index 1)))
  10.          ((fx= ,index ,limit))
  11.        ,@body)))
  12.  
  13. ;(define (link modules out-spec)
  14. ;  (with-open-streams
  15. ;   ((image (open (filename-with-type filename 'apollo_image) 'out))
  16. ;    (map   (open (filename-with-type filename 'apollo_map) 'out))
  17. ;    (noise (open (filename-with-type filename 'apollo_noise) 'out)))
  18. ;   (bind ((*linker-noise-file* (make-broadcast-stream (standard-output)
  19. ;                                                      noise-file)))
  20. ;     (linker-message "~&Linking ~a ... ~%" out-spec)
  21. ;     (really-link modules image map noise))))
  22.  
  23. (define (link modules out-spec)
  24.   (really-link modules 'mo out-spec 'image))
  25.  
  26. (define-constant %%d-ieee-size 53)
  27. (define-constant %%d-ieee-excess 1023)
  28.  
  29. (define (write-double-float stream float)
  30.   (receive (sign mantissa exponent)
  31.            (normalized-float-parts float
  32.                                    %%d-ieee-size 
  33.                                    %%d-ieee-excess 
  34.                                    t)
  35.     (write-int stream header/double-float)
  36.     (write-half stream (fx+ (fixnum-ashl sign 15)
  37.                             (fx+ (fixnum-ashl exponent 4)
  38.                                  (bignum-bit-field mantissa 48 4))))
  39.     (write-half stream (bignum-bit-field mantissa 32 16)) 
  40.     (write-half stream (bignum-bit-field mantissa 16 16)) 
  41.     (write-half stream (bignum-bit-field mantissa 0 16))))
  42.   
  43. (define (write-vcell-header var stream)
  44.   (write-half stream 0)
  45.   (write-byte stream (if (fx= (vector-length (var-node-refs var))
  46.                   0)
  47.              0
  48.              -1))
  49.   (write-byte stream (if (eq? (var-node-defined var) 'define)
  50.              (fx+ header/vcell 128)
  51.              header/vcell)))
  52.  
  53. (define (write-template stream tmplt)
  54.   (write-byte stream (cit-pointer tmplt))
  55.   (write-byte stream (cit-scratch tmplt))
  56.   (write-half stream (cit-unit-offset tmplt))
  57.   (write-byte stream (cit-header/nary? tmplt))
  58.   (write-byte stream (cit-nargs tmplt))
  59.   (write-half stream M68-JUMP-ABSOLUTE)
  60.   (write-int  stream 
  61.               (fx+ (heap-offset (table-entry *reloc-table* (cit-code-vec tmplt)))
  62.                           (fx+ CELL (cit-aux-offset tmplt))))) ;; for header
  63.  
  64.  
  65. ;;; fetch the template store slots out of the closure-internal-template's
  66. ;;; auxiliary template.                  
  67.  
  68. (define (set-template-store-slots ts code index offset)
  69.   (set (cit-unit-offset ts) (fx* (fx+ offset 1) CELL))
  70.   (set (cit-pointer ts) (bref-8 code (fx- index 6)))
  71.   (set (cit-scratch ts) (bref-8 code (fx- index 5)))
  72.   (set (cit-nargs ts)   (bref-8 code (fx- index 1)))
  73.   (set (cit-header/nary? ts) (bref-8 code (fx- index 2)))
  74.   (set (cit-code-vec ts) code)
  75.   (set (cit-aux-offset ts) index))
  76.  
  77. (define (vgc-copy-foreign foreign)
  78.   (let* ((heap (lstate-impure *lstate*))
  79.          (addr (area-frontier heap))
  80.          (name (foreign-object-name foreign))
  81.          (desc (object nil
  82.                  ((heap-stored self) (lstate-impure *lstate*))
  83.                  ((heap-offset self) addr)
  84.                  ((write-descriptor self stream)
  85.                   (write-data stream (fx+ addr tag/extend)))
  86.                  ((write-store self stream)
  87.                   (write-int stream header/foreign)
  88.                   (write-slot name stream)
  89.                   (write-int stream 0)))))
  90.     (set (area-frontier heap) (fx+ addr (fx* CELL 3)))
  91.     (set-table-entry *reloc-table* foreign desc)
  92.     (push (area-objects heap) desc)                
  93.     (generate-slot-relocation name (fx+ addr CELL))
  94.     (push (lstate-foreign-reloc *lstate*)
  95.           (cons (symbol->string name)
  96.                 (fx+ addr (fx* CELL 2))))
  97.     desc))
  98.  
  99.  
  100. (define (relocate-unit-variable var addr external?)
  101.   (let ((type (var-value-type var)))
  102.    (cond (type
  103.     (cond ((and external? (neq? (var-node-value var) NONVALUE))
  104.            (push (lstate-symbols *lstate*)
  105.                  (cons (var-node-name var) (unit-var-value (var-node-value var))))
  106.            (reloc-thunk type addr))
  107.           (else
  108.            (reloc-thunk type addr)))))))
  109.  
  110. (define (var-value-type var)
  111.   (let ((value (var-node-value var)))
  112.     (cond ((eq? value NONVALUE) 
  113.            (vgc (var-node-name var))
  114.            nil)
  115.           ((unit-loc? value) 'DATA)
  116.           (else
  117.            (let ((desc (vgc value)))
  118.              (if (eq? (heap-stored desc) (lstate-impure *lstate*))
  119.                  'DATA                                                                
  120.                  'TEXT))))))
  121.         
  122. (define (generate-slot-relocation obj slot-address)
  123.   (cond ((or (fixnum? obj) (char? obj) (eq? obj '#t)))
  124.         (else                                               
  125.          (heap-reloc-thunk slot-address (vgc obj)))))
  126.  
  127.                   
  128. (define (text-relocation addr)
  129.   (push (lstate-text-reloc *lstate*) addr))
  130.  
  131. (define (data-relocation addr)
  132.   (push (lstate-data-reloc *lstate*) addr))
  133.  
  134.  
  135. (define (heap-reloc-thunk slot-address desc)
  136.   (if (eq? (heap-stored desc) (lstate-impure *lstate*))
  137.            (push (lstate-data-reloc *lstate*) slot-address)
  138.            (push (lstate-text-reloc *lstate*) slot-address)))
  139.    
  140.  
  141. (define (reloc-thunk type slot-address)
  142.   (if (eq? type 'data)
  143.       (push (lstate-data-reloc *lstate*) slot-address)
  144.       (push (lstate-text-reloc *lstate*) slot-address)))
  145.  
  146.  
  147. (define (write-slot obj stream)
  148.   (cond ((table-entry *reloc-table* obj)
  149.          => (lambda (desc) (write-descriptor desc stream)))
  150.         ((fixnum? obj)
  151.          (write-fixnum stream obj))
  152.         ((char? obj)
  153.          (write-int stream (fx+ (fixnum-ashl (char->ascii obj) 8)
  154.                                  header/char)))
  155.         ((eq? obj '#t)
  156.          (write-int stream header/true))
  157.         (else
  158.          (error "bad immediate type ~s" obj))))
  159.  
  160. (define (write-data stream int)
  161.   (write-int stream int))
  162.  
  163. (define-integrable (write-int stream int)
  164.   (write-half stream (fixnum-ashr int 16))
  165.   (write-half stream int))
  166.  
  167. (define (write-half stream int)
  168.   (write-byte stream (fixnum-ashr int 8))
  169.   (write-byte stream int))
  170.  
  171. (define-integrable (write-byte stream n)
  172.   (writec stream (ascii->char (fixnum-logand n 255))))
  173.                                  
  174. (define-integrable (write-fixnum stream fixnum)
  175.   (write-half stream (fixnum-ashr fixnum 14))
  176.   (write-half stream (fixnum-ashl fixnum 2)))
  177.  
  178. (define (write-link-file stream)
  179.   (write-header     stream)
  180.   (write-area       stream (lstate-pure *lstate*))
  181.   (write-area       stream (lstate-impure *lstate*))
  182.   (write-relocation stream (lstate-text-reloc *lstate*))
  183.   (write-relocation stream (lstate-data-reloc *lstate*))
  184.   (write-foreign-relocation stream (lstate-foreign-reloc *lstate*)))
  185.  
  186. (define (write-header stream)
  187.   (let* ((text-size (area-frontier (lstate-pure *lstate*)))
  188.          (data-size (area-frontier (lstate-impure *lstate*))))
  189.     (cond ((assq 'big_bang (lstate-symbols *lstate*))
  190.            => (lambda (pair)
  191.                 (write-int stream (cdr pair)))) ; entry point
  192.           (else
  193.            (error "big_bang not defined")))
  194.     (write-int stream (fx* (length (lstate-text-reloc *lstate*)) 4))
  195.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) 4))
  196.     (write-int stream (foreign-reloc-size (lstate-foreign-reloc *lstate*)))
  197.     (write-int stream text-size)
  198.     (write-int stream data-size)))
  199.  
  200. (define (write-area stream area)
  201.   (walk (lambda (x) (write-store x stream))
  202.         (reverse! (area-objects area))))
  203.  
  204.  
  205. (define (write-relocation stream items)
  206.   (walk (lambda (addr) (write-int stream addr)) (sort-list! items fx<)))
  207.                              
  208. (define (write-map-entry stream name value)
  209.   (if (unit-loc? value)
  210.       (format stream "~s~20t~x~%" name 
  211.          (fx+ (heap-offset (table-entry *reloc-table* (unit-loc-unit value)))
  212.               (fx+ (unit-loc-offset value) tag/extend)))))
  213.                                 
  214.  
  215. (define (write-foreign-relocation stream syms)
  216.   (walk (lambda (sym)
  217.           (destructure (((name . addr) sym))
  218.             (write-int stream addr)
  219.             (write-string stream name)
  220.             (dotimes (i (fx- 32 (string-length name)))
  221.               (write-byte stream 32))))
  222.         syms))
  223.  
  224. (define (foreign-reloc-size syms)  ; syms are (name . addr)
  225.   (fx* (length syms) 36))
  226.